﻿#light

namespace FsSignals  
 module Signal =
 
    open System
    open Microsoft.FSharp.Control 
    open Microsoft.FSharp.Collections
    
    

    let cst x = fun _ -> x
        
    let (==) a b = (a:>obj) = (b:>obj)
    
    let  extract pred l =
        let rec proc ll e lr =
            match (lr, pred e) with
            |lr, Some v -> (Some v, ll @ lr)
            |[], None -> (None, ll)
            |h::t, None -> proc (e::ll) h t
        match l with
        |[] -> None, []
        |h::t -> proc [] h t

    type InvalidSignal =
        {
            compute: World -> World
            level: int
        }
    and  World = World of (InvalidSignal list * int * (unit->unit) list)

    type Signal<'a> =
        {
            level : unit -> int
            addDependent : 'a Dependent -> unit
            removeDependent : 'a Dependent -> unit
            dispose : unit -> unit
        }
    and 'a Dependent =
        {
            notifyValueChange : 'a option -> Signal<'a> option -> World -> World  
        }
        with
            static member make fv = {notifyValueChange = fv}

    let dispose (sa:Signal<'a>) = sa.dispose()
   
        

    type World
        with
            static member empty  = World ([], 0, [])
            static member from s = World ([s], 0, [])
            static member  run  =
                let rec run' (World (l, level, sl) as world : World) =
                    if l.IsEmpty
                    then ()
                    else
                        match extract (fun (s:InvalidSignal) -> if s.level = level then Some s else None) l with
                        |Some first, l ->   let world' = first.compute (World (l, level, sl))
                                            run' world'
                        |None, _ -> run' (World (l, level+1, sl))
                run'   
            static member  runStrChange  =
                let rec run' (World (_, _, l) as world : World) =
                    List.iter (fun f -> f()) l
                run'   
            static member add  = fun (World (l, level, sl)) s -> World (s::l, level, sl)
            static member addSigChange  = fun (World (l, level, sl)) s -> World (l, level, s::sl)


    type MutableList<'a>() =
        let lref = ref []
        with
            member l.clear () = lref := []
            member l.add (e:'a) = lref := e::(!lref)
            member l.get() = !lref
            member l.isEmpty() = List.isEmpty (l.get())
            member l.remove e =
                    let proc e' = not (e' == e)
                    lref := List.filter proc (!lref)
                    
    type 'a DepList = MutableList<'a Dependent>
    

    let source<'a>() =
        let dependents = DepList<'a> ()
        let notifyValue v world = dependents.get() |>  List.fold (fun world dep -> dep.notifyValueChange (Some v) None world) world
    
        let changeValue (v:'a)  =
                let invalidSig =
                    {
                        compute = notifyValue v
                        level = 0

                    }
                let world = World.from invalidSig
                World.run world

        let dispose () = 
            if not (dependents.isEmpty()) then failwith "still referenced"

        let rec baseSignal =
            {
                level = fun () -> 0
                addDependent = dependents.add
                removeDependent = dependents.remove
                dispose = dispose
            }
        (baseSignal, changeValue)


    let sourceEvent (e:IEvent<_,_>) =
        let dependents = DepList<'a> ()
        let notifyValue v world = dependents.get() |>  List.fold (fun world dep -> dep.notifyValueChange (Some v) None world) world
    
        let changeValue (v:'a)  =
                let invalidSig =
                    {
                        compute = notifyValue v
                        level = 0

                    }
                let world = World.from invalidSig
                World.run world
        let disposable = e.Subscribe changeValue
  
        let dispose () = 
            if dependents.isEmpty() 
            then disposable.Dispose()
            else failwith "still referenced"

        let removeDependent dep =   dependents.remove dep
                                    if (dependents.isEmpty() )
                                    then dispose()
                                    else ()

        let rec baseSignal =
            {
                level = fun () -> 0
                addDependent = dependents.add
                removeDependent = removeDependent
                dispose = dispose
            }
        baseSignal


    let none<'a>() : Signal<'a> =
        let rec baseSignal =
            {
                level = fun () -> 0
                addDependent = fun _ -> ()
                removeDependent = fun _ -> ()
                dispose = id
            }
        baseSignal

  
    let rec private genericMap notifyValueChange  (sa : Signal<'a>) =
        let dependents = DepList<_> ()
            
        let rec thisDependent = Dependent<_>.make (notifyValueChange dependents (lazy(thisDependent)))
        
        let dispose () = 
            if dependents.isEmpty() 
            then sa.removeDependent thisDependent
            else failwith "still referenced"

        let removeDependent dep =   dependents.remove dep
                                    if (dependents.isEmpty() )
                                    then dispose()
                                    else ()
        let s =
            {
                level = sa.level
                addDependent = dependents.add
                removeDependent = removeDependent
                dispose = dispose
            }
        sa.addDependent thisDependent
        s
        
        
    let rec map (f: 'a -> 'b) (sa : Signal<'a>) =
        let notifyValueChange (dependents:MutableList<_>) (thisDependent:Lazy<_>) v nsa world = 
            let nv = match v with
                     |Some v -> Some (f v)
                     |none -> None
            let ns = match nsa with
                     |Some nsa ->   sa.removeDependent (thisDependent.Force())
                                    Some (map f nsa)
                     |None -> None
            dependents.get() |> List.fold (fun world dep -> dep.notifyValueChange nv ns world) world 
        genericMap notifyValueChange sa
    
    
    let rec filter (f: 'a -> bool) (sa : Signal<'a>) =
        let notifyValueChange (dependents:MutableList<_>) (thisDependent:Lazy<_>) v nsa world = 
            let nv = match v with
                     |Some v -> match f v with
                                |true -> Some v
                                |false -> None
                     |none -> None
            let ns = match nsa with
                     |Some nsa ->   sa.removeDependent (thisDependent.Force())
                                    Some (filter f nsa)
                     |None -> None
            match (nv, ns) with
            |None, None -> world
            |_ -> dependents.get() |> List.fold (fun world dep -> dep.notifyValueChange nv ns world) world 
        genericMap notifyValueChange sa   


    let rec choose (f: 'a -> 'b option) (sa : Signal<'a>) =
        let notifyValueChange (dependents:MutableList<_>) (thisDependent:Lazy<_>) v nsa world = 
            let nv = match v with
                     |Some v -> f v
                     |none -> None
            let ns = match nsa with
                     |Some nsa ->   sa.removeDependent (thisDependent.Force())
                                    Some (choose f nsa)
                     |None -> None
            match (nv, ns) with
            |None, None -> world
            |_ -> dependents.get() |> List.fold (fun world dep -> dep.notifyValueChange nv ns world) world 
        genericMap notifyValueChange sa   



    let rec chooseSig  (sa : Signal<'a option>) =
        let notifyValueChange (dependents:MutableList<_>) (thisDependent:Lazy<_>) v nsa world = 
            let nv = match v with
                     |Some v -> v
                     |none -> None
            let ns = match nsa with
                     |Some nsa ->   sa.removeDependent (thisDependent.Force())
                                    Some (chooseSig nsa)
                     |None -> None
            match (nv, ns) with
            |None, None -> world
            |_ -> dependents.get() |> List.fold (fun world dep -> dep.notifyValueChange nv ns world) world 
        genericMap notifyValueChange sa   


    let rec merge (sa : Signal<'a>) (sb : Signal<'b>)=
        let dependents = DepList<_> ()
        let changeRef = (None, None) |> ref
        let levelRef = Math.Max(sa.level(), sb.level()) |> ref
        let shouldNotifyRef = ref true 
        
        let notifyValue deps v s world = deps |>  List.fold (fun world dep -> dep.notifyValueChange v s world) world

        let level() = !levelRef
        
        let reset() = 
                changeRef := (None, None)
                shouldNotifyRef := true 
        
        let rec compute left right world = 
            let (va, nsa, vb, nsb) = 
                match left, right with
                |None, None -> failwith "error"
                |Some (None, None) , Some (None, None) -> failwith "error"
                |Some (va, nsa) , Some (vb, nsb) -> va, nsa, vb, nsb
                |Some (va, nsa) , None -> va, nsa, None, None
                |None , Some (vb, nsb) -> None, None, vb, nsb
            
            let nv = match va, vb with
                     |None, None -> None
                     |va, vb -> Some (va, vb)
            let world' =
                match nsa, nsb with
                |None, None -> notifyValue (dependents.get()) nv None world
                |Some nsa, Some nsb ->  let ns = merge nsa nsb
                                        sa.removeDependent thisLeftDependent
                                        sb.removeDependent thisRightDependent
                                        notifyValue (dependents.get()) nv (Some ns) world
                |Some nsa, None ->  let ns = merge nsa sb
                                    sa.removeDependent thisLeftDependent
                                    notifyValue (dependents.get()) nv (Some ns) world
                |None, Some nsb ->  let ns = merge sa nsb
                                    sb.removeDependent thisRightDependent
                                    notifyValue (dependents.get()) nv (Some ns) world
            reset()
            world'
        
        and invalidSig level changeRef =
            {
                compute = fun world -> let (left, right) = !changeRef
                                       compute left right world
                level = level
            }
                                
        and notifyLeftValueChange nv ns world =  
                changeRef :=    match !changeRef with
                                |None, r -> Some (nv, ns), r 
                                |_, r -> failwith "error"
                if !shouldNotifyRef 
                then    shouldNotifyRef := false
                        World.add world (invalidSig !levelRef changeRef)
                else world

        and notifyRightValueChange nv ns world =  
                changeRef :=    match !changeRef with
                                |l, None -> l, Some (nv, ns)
                                |l, _ -> failwith "error"
                if !shouldNotifyRef 
                then    shouldNotifyRef := false
                        World.add world (invalidSig !levelRef changeRef)
                else world
                
        and thisLeftDependent = Dependent<_>.make notifyLeftValueChange
        and thisRightDependent = Dependent<_>.make notifyRightValueChange
        
        let dispose () = 
            if dependents.isEmpty() 
            then    sa.removeDependent thisLeftDependent
                    sb.removeDependent thisRightDependent
            else failwith "still referenced"

        let removeDependent dep =   dependents.remove dep
                                    if (dependents.isEmpty() )
                                    then    dispose()
                                    else ()
        let s =
            {
                level = level
                addDependent = dependents.add
                removeDependent = removeDependent
                dispose = dispose
            }
        sa.addDependent thisLeftDependent
        sb.addDependent thisRightDependent
        s

    
    let holdPair sa =
        let valRef = ref (None, None) 
        let proc v = 
            valRef :=   match v with
                        |None, None -> failwith "error"
                        |Some l, Some r -> v
                        |Some l, None -> Some l, snd (!valRef)
                        |None, Some r ->  fst (!valRef), Some r
            match !valRef with
            |Some l, Some r -> Some (l, r)
            |_ -> None
        choose proc sa
     
     
    let applySig fa sa =
            let mergedSig = merge fa sa
            let deltaSig = holdPair mergedSig
            let proc (f, v) = f v
            map proc deltaSig
        
    
    let rec private innerSwitch (sa : Signal<'a option * Signal<'a> option>) =
    
        let dependents = DepList<'a> ()
        let notifyValueChange v ns world = dependents.get() |>  List.fold (fun world dep -> dep.notifyValueChange v ns world) world
            
        let rec compute v ns world =  
                match v, ns with
                |None, None -> failwith "error"
                |None, Some nsa  -> let ns = innerSwitch nsa
                                    sa.removeDependent thisDependent
                                    notifyValueChange None (Some ns) world
                |Some (None, None), None -> failwith "error"
                |Some (Some va, None), None -> notifyValueChange (Some va) None world
                |Some (vao, Some switchedSa), _ ->  sa.removeDependent thisDependent
                                                    notifyValueChange vao (Some switchedSa) world
                |Some (vao, None), Some nsa ->  let ns = innerSwitch nsa
                                                sa.removeDependent thisDependent
                                                notifyValueChange vao (Some ns) world
                |_ -> failwith "error"

        and thisDependent = Dependent<'a>.make compute
        
        let dispose () = 
            if dependents.isEmpty() 
            then    sa.removeDependent thisDependent
            else failwith "still referenced"

        let removeDependent dep =   dependents.remove dep
                                    if (dependents.isEmpty() )
                                    then dispose()
                                    else ()
        let s =
            {
                level = sa.level
                addDependent = dependents.add
                removeDependent = removeDependent
                dispose = dispose
            }
        sa.addDependent thisDependent
        s
  
  
    let switch (sa : Signal<'a>) (sb: Signal<Signal<'a>>) = 
            let mergedSig = merge sa sb
            innerSwitch mergedSig

    let  wait (sa: Signal<Signal<'a>>) = switch (none()) sa

        
    let (<*>) f a =  applySig f a

// val ( =>> ) : Signal<'a> -> ('a -> 'b) -> Signal<'b>
    let (=>>) s f = map f s

// val ( --> ) : Signal<'a> -> 'b -> Signal<'b>


    let rec (-->) ea b  =  ea =>> (fun _ -> b)

    let rec (==>>) ea f  =  ea =>> (fun _ -> f())




// val stepAccumSig : 'a -> ('a -> 'a) Signal -> 'a Signal
    
    let mergeExc sa sb =
        let s = merge sa sb
        let proc v =
            match v with
            |Some va, _ -> va
            |_, Some vb -> vb
            |_ -> failwith "error"
        s =>> proc
        
    let stepAccumSig (a: 'a) (evt : Signal<'a ->'a>) =
        let accum =  ref a
        let proc f =    accum := f !accum
                        !accum
        map proc evt
    

    let sample sa sb =
        let s = merge sa sb
        let valRef = ref None 
        let proc v = 
            valRef :=   match v with
                        |None, None -> failwith "error"
                        |Some l, _ ->   Some l
                        |None,_ -> !valRef
            match v with
            |_, Some r -> //printfn "sample: %A" (!valRef)
                          !valRef
            |_ -> None
        choose proc s

// val whileSig : Signal<bool> -> Signal<unit>

    let whileSig (sa:Signal<bool>) = filter id sa |> map (fun _ -> ())

    
// val whenSig : Signal<bool> -> Signal<unit>
    let whenSig (sa:Signal<bool>) =
        let previous =  ref false
        let proc v =
            let r = match !previous, v with
                    |(true, true) -> false
                    |(false, true) -> true
                    |(true, false) -> false
                    |(false, false) -> false
            previous := v
            r
        filter proc sa |> map (fun _ -> ())


     
    let iterSig l s =
        let lref = ref l
        let loopProc e =    match !lref with
                            |[] ->  None
                            |h::t ->    lref := t
                                        Some h  
        choose loopProc s
    
    let iterNotifySig l s =
        let lref = ref l
        let proc e =    match !lref with
                        |[] ->  (None, true)
                        |h::t ->    lref := t
                                    (Some h, false)  
        let s' = s =>> proc
        let res = chooseSig (s' =>> fst)
        let notifier = s' =>> snd
        (res, notifier)
    


    let loopSig l s =
        let lref = ref l
        let loopProc e =    match !lref with
                            |[] ->  None

                            |h::t ->    lref :=  (t @ [h])
                                        Some h  
        choose loopProc s
    
    let scan   f (s:'state) sa  =
        let stateRef = ref s
        let proc v =    stateRef := f (!stateRef) v
                        !stateRef
        sa =>> proc

    type 'a Alias = Alias of ('a -> unit) * (unit -> 'a)
        with
            member a.get =  let (Alias (get, _)) = a
                            get
            member a.set =  let (Alias (_, set)) = a
                            set

    let aliasSig v0 = 
        let refVal = ref v0
        let set v = refVal := v
        let get() = !refVal
        Alias (get, set)

    let bindSig (alias: 'a Alias) (sa:Signal<'a>) =
        let proc (v:'a) =  
            alias.set v
            v 
        sa =>> proc
    
    let (<.>) f s = s =>> f

    let integrateSig v0 t0 sa (time:Signal<float>) =
        let i0Ref = ref v0
        let t0Ref = ref t0
        let proc v t =  i0Ref := !i0Ref + v * (t - !t0Ref)
                        t0Ref := t
                        !i0Ref
        proc <.> sa <*> time

// usefull functions
    let two sa sb = (fun a b -> a,b) <.> sa <*> sb
    let three sa sb sc = (fun a b c-> a,b,c) <.> sa <*> sb <*> sc

// state machine

    let onceThen (sa:Signal<'a>) makeNextSig = 
        switch sa (sa =>> makeNextSig)

    let (.||.) (sa:Signal<'a>) (sa':Signal<'a>) = mergeExc sa sa'

(*


    let integrateSig vi sa (time:Signal<float>) =
        let i0Ref = ref vi
        let t0  = time.value()
        let t0Ref = ref t0
        let proc v t =  i0Ref := !i0Ref + v * (t - !t0Ref)
                        t0Ref := t
                        // printfn "---------->         %A" (!i0Ref)
                        !i0Ref
        pureS proc <*> sa <*> time


    let rec aliasSig a =
        let dependents = DepList<'a> ()
        let notifyVal world = dependents.get() |>  List.fold (fun world dep -> dep.notifyValueChange  world) world
        let (setp, getp) = mkValue()
        let level = fun () -> 0
        let rec compute world = notifyVal world

        and notifyValChange world =   

            let invalidSig =
                    {
                        compute = compute
                        level = level
                    }
            World.add world invalidSig
        and thisDependent = let (dep : 'a Dependent) = Dependent<'a>.make notifyValChange (fun _ w -> w)    
                            dep         

        let removeDependent dep = dependents.remove dep
                              
        let s =
            {
                level = level
                value = getp

                addDependent = dependents.add
                propagateAddDependent = fun _ -> ()
                removeDependent = dependents.remove
                propagateRemoveDependent = fun _ -> ()
                die = id
            }
        (s, (thisDependent, fun v -> setp v))

        
    
    let rec bindSig (alias, (aliasDep, changeAlias)) sa  =
        let dependents = DepList<'a> ()
        let notifyVal world = dependents.get() |>  List.fold (fun world dep -> dep.notifyValueChange  world) world
        let notifySig ns world = dependents.get() |>  List.fold (fun world dep -> dep.notifySignalChange ns world) world
        let currentRef =    sa.value() |> ref

        let levelVal =  sa.level () + 1
        let level() = levelVal
        let (setp, getp) = mkValue()
                                 
        let rec compute changeVal changeSig world =
                
                let world' =    
                    match changeVal with
                    |SameVal -> world
                    |NewVal ->  let v = sa.value()
                                setp v
                                changeAlias v
                                notifyVal world
                let world'' =
                    match changeSig with
                    |SameSig -> world'
                    |Die -> let world'' = notifySig Die world'
                            dependents.clear()
                            world''
                    |NewSig nsa ->  let ns = bindSig (alias, (aliasDep, changeAlias)) nsa
                                    let world'' = notifySig (NewSig ns) world'
                                    dependents.clear()
                                    world''
                thisDependent.reset()
                world''

        and thisDependent = makeUnaryDep compute level

        let die ()  =
                let invalidSig =
                    {
                        compute = fun world -> notifySig Die world
                        level = level
                    }
                let world = World.from invalidSig
                World.run world

        let removeDependent dep =   dependents.remove dep
                                    if (dependents.isEmpty() )
                                    then    sa.removeDependent (thisDependent.dependent)   

                                            sa.propagateRemoveDependent aliasDep
                                    else ()
        let propagateAddDependent dep = sa.propagateAddDependent dep
        let propagateRemoveDependent dep =  sa.propagateRemoveDependent dep
        let s =
            {
                level = level
                value = getp

                addDependent = dependents.add
                propagateAddDependent = propagateAddDependent
                removeDependent = dependents.remove
                propagateRemoveDependent = propagateRemoveDependent
                die = die
            }
        sa.addDependent (thisDependent.dependent)
        sa.propagateAddDependent aliasDep
        s


*)


    let rec print (sa:Signal<'a>) = map (fun va ->  printfn "%A\n" va
                                                    va) sa


